;;;----------------------------------------------------------------------------
;;;
;;; Subject: Producto Amalgamado
;;; 
;;; X = K(Z/2Z,1), Y = K(Z/4Z,1) , Z = K(Z/6Z,1)
;;;
;;;
;;;----------------------------------------------------------------------------

(load "resolutions")
(load "pushout-list")
(load-pushoutfiles)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun kzps-incl (n m)
  (declare (number n m))
  (let ((i (/ m n)))
    (build-smmr
     :sorc (k-zp-1 n)
     :trgt (k-zp-1 m)
     :degr 0
     :sintr #'(lambda (dmns gmsm)
                (declare (ignore gmsm))
                (absm 0 (make-list dmns :initial-element i) ))
     :orgn  `(inclusion between (k-g-1 ,n) and (k-g-1 ,m))))) 

(cat-init)

(setf incl1 (kzps-incl 2 4))
(setf incl2 (kzps-incl 2 6)) 

(setf p (pushout incl1 incl2))

;;; H_0(P) = Z

(homology p 0)

;;; H_1(P) = Z/12Z

(homology p 1)

;;; H_2(P) = 0

(homology p 2)

;;; H_3(P) = Z/12Z

(homology p 3)

;;; H_4(P) = 0

(homology p 4)

;;; H_5(P) = Z/12Z

(homology p 5)



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;  Reduced version 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


(defun basis-reduced (p)
  (flet ((rslt (dmns)
               (declare (fixnum dmns))
               (cond ((equal dmns 0) (list (bspn p)))
                     ((equal dmns 1) (cdr (basis p 1)))
                     (t (basis p dmns)))))
    (the basis #'rslt)))


(defun face-reduced (p)
  (flet ((rslt (indx dmns gmsm)
               (cond ((equal dmns 1) (absm 0 (bspn p)))
                     (t (with-absm (dgop pgmsm) (face p indx dmns gmsm)
                          (with-pushout-gsm (ind old) pgmsm
                            (ecase ind
                              (0 (cond ((equal 
                                         (cmpr (crts-prdc (k-zp-1 2) (delta 1))                                         
                                               old (p-old (car (basis p 1)))) ':EQUAL)
                                        (absm (- (expt 2 dmns) 1) (pushout-gsm 1 nil)))
                                       (t (absm dgop pgmsm))))
                              (1 (absm dgop pgmsm))
                              (2 (cond ((equal old nil) (absm dgop (pushout-gsm 1 nil)))
                                       (t (absm dgop pgmsm))))
                            )))))))
    (the face #'rslt)))

(setf p-reduced (build-smst
                 :cmpr (cmpr p)
                 :basis (basis-reduced p)
                 :bspn (bspn p)
                 :face (face-reduced p)
                 :orgn `(pushout-reduced ,p)))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;  Computing Homotopy groups
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(load "fundamental-classes")
(load "cylinders")

(setf suspension-p-reduced (suspension p-reduced))
(setf ch (chml-clss suspension-p-reduced 2))
(setf tau (zp-whitehead 12 suspension-p-reduced ch))
(setf x (fibration-total tau))

(homology x 3)

;; pi_3 = Z/12Z

(setf ch2 (chml-clss x 3))
(setf tau2 (zp-whitehead 12 x ch2))
(setf x2 (fibration-total tau2))

(homology x2 4)

;; pi_4 = Z/12Z + Z/2Z

(setf ch3 (chml-clss x2 4))
(setf tau3 (z2-whitehead x2 ch3))
(setf x3 (fibration-total tau3))
(setf ch4 (chml-clss x3 4))
(setf tau4 (zp-whitehead 12 x3 ch4))
(setf x4 (fibration-total tau4))
